home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2005 October / PCWOCT05.iso / Software / FromTheMag / The GIMP 2.2.8 / gimp-2.2.8-i586-setup.exe / {app} / share / gimp / 2.0 / scripts / hsv-graph.scm < prev    next >
Encoding:
GIMP Script-Fu Script  |  2005-06-30  |  12.5 KB  |  353 lines
  1. ;;; hsv-graph.scm -*-scheme-*-
  2. ;;; Author: Shuji Narazaki <narazaki@InetQ.or.jp>
  3. ;;; Time-stamp: <1998/01/18 05:25:03 narazaki@InetQ.or.jp>
  4. ;;; Version: 1.2
  5. ; ************************************************************************
  6. ; Changed on Feb 4, 1999 by Piet van Oostrum <piet@cs.uu.nl>
  7. ; For use with GIMP 1.1.
  8. ; All calls to gimp-text-* have been converted to use the *-fontname form.
  9. ; The corresponding parameters have been replaced by an SF-FONT parameter.
  10. ; ************************************************************************
  11. ;;; Code:
  12.  
  13. (if (not (symbol-bound? 'script-fu-hsv-graph-scale (the-environment)))
  14.     (define script-fu-hsv-graph-scale 1))
  15. (if (not (symbol-bound? 'script-fu-hsv-graph-opacity (the-environment)))
  16.     (define script-fu-hsv-graph-opacity 100))
  17. (if (not (symbol-bound? 'script-fu-hsv-graph-bounds? (the-environment)))
  18.     (define script-fu-hsv-graph-bounds? TRUE))
  19. (if (not (symbol-bound? 'script-fu-hsv-graph-left2right? (the-environment)))
  20.     (define script-fu-hsv-graph-left2right? FALSE))
  21. (if (not (symbol-bound? 'script-fu-hsv-graph-beg-x (the-environment)))
  22.     (define script-fu-hsv-graph-beg-x 0))
  23. (if (not (symbol-bound? 'script-fu-hsv-graph-beg-y (the-environment)))
  24.     (define script-fu-hsv-graph-beg-y 0))
  25. (if (not (symbol-bound? 'script-fu-hsv-graph-end-x (the-environment)))
  26.     (define script-fu-hsv-graph-end-x 1))
  27. (if (not (symbol-bound? 'script-fu-hsv-graph-end-y (the-environment)))
  28.     (define script-fu-hsv-graph-end-y 1))
  29.  
  30. (define (script-fu-hsv-graph img drawable scale opacity bounds?
  31.                  left2right? beg-x beg-y end-x end-y)
  32.   (define (floor x) (- x (fmod x 1)))
  33.   (define *pos* #f)
  34.   (define (set-point! fvec index x y)
  35.     (aset fvec (* 2 index) x)
  36.     (aset fvec (+ (* 2 index) 1) y)
  37.     fvec)
  38.  
  39.   (define (plot-dot img drawable x y)
  40.     (gimp-pencil drawable 1 (set-point! *pos* 0 x y)))
  41.  
  42.   (define (rgb-to-hsv rgb hsv)
  43.     (let* ((red (floor (nth 0 rgb)))
  44.        (green (floor (nth 1 rgb)))
  45.        (blue (floor (nth 2 rgb)))
  46.        (h 0.0)
  47.        (s 0.0)
  48.        (minv (min red (min green blue)))
  49.        (maxv (max red (max green blue)))
  50.        (v maxv)
  51.        (delta 0))
  52.       (if (not (= 0 maxv))
  53.       (set! s (/ (* (- maxv minv) 255.0) maxv))
  54.       (set! s 0.0))
  55.       (if (= 0.0 s)
  56.       (set! h 0.0)
  57.       (begin
  58.         (set! delta (- maxv minv))
  59.         (cond ((= maxv red)
  60.            (set! h (/ (- green blue) delta)))
  61.           ((= maxv green)
  62.            (set! h (+ 2.0 (/ (- blue red) delta))))
  63.           ((= maxv blue)
  64.            (set! h (+ 4.0 (/ (- red green) delta)))))
  65.         (set! h (* 42.5 h))
  66.         (if (< h 0.0)
  67.         (set! h (+ h 255.0)))
  68.         (if (< 255 h)
  69.         (set! h (- h 255.0)))))
  70.       (set-car! hsv (floor h))
  71.       (set-car! (cdr hsv) (floor s))
  72.       (set-car! (cddr hsv) (floor v))))
  73.  
  74.   ;; segment is
  75.   ;;   filled-index (integer)
  76.   ;;   size as number of points (integer)
  77.   ;;   vector (which size is 2 * size)
  78.   (define (make-segment length x y)
  79.     (if (< 64 length)
  80.     (set! length 64))
  81.     (if (< length 5)
  82.     (set! length 5))
  83.     (let ((vec (cons-array (* 2 length) 'double)))
  84.       (aset vec 0 x)
  85.       (aset vec 1 y)
  86.       (list 1 length vec)))
  87.  
  88.   ;; accessors
  89.   (define (segment-filled-size segment) (car segment))
  90.   (define (segment-max-size segment) (cadr segment))
  91.   (define (segment-strokes segment) (caddr segment))
  92.  
  93.   (define (fill-segment! segment new-x new-y)
  94.     (define (shift-segment! segment)
  95.       (let ((base 0)
  96.         (size (cadr segment))
  97.         (vec (caddr segment))
  98.         (offset 2))
  99.     (while (< base offset)
  100.            (aset vec (* 2 base)
  101.              (aref vec (* 2 (- size (- offset base)))))
  102.            (aset vec (+ (* 2 base) 1)
  103.              (aref vec (+ (* 2 (- size (- offset base))) 1)))
  104.            (set! base (+ base 1)))
  105.     (set-car! segment base)))
  106.     (let ((base (car segment))
  107.       (size (cadr segment))
  108.       (vec (caddr segment)))
  109.       (if (= base 0)
  110.       (begin
  111.         (shift-segment! segment)
  112.         (set! base (segment-filled-size segment))))
  113.       (if (and (= new-x (aref vec (* 2 (- base 1))))
  114.            (= new-y (aref vec (+ (* 2 (- base 1)) 1))))
  115.       #f
  116.       (begin
  117.         (aset vec (* 2 base) new-x)
  118.         (aset vec (+ (* 2 base) 1) new-y)
  119.         (set! base (+ base 1))
  120.         (if (= base size)
  121.         (begin
  122.           (set-car! segment 0)
  123.           #t)
  124.         (begin
  125.           (set-car! segment base)
  126.           #f))))))
  127.  
  128.   (define (draw-segment img drawable segment limit rgb)
  129.     (gimp-context-set-foreground rgb)
  130.     (gimp-airbrush drawable 100 (* 2 limit) (segment-strokes segment)))
  131.  
  132.   (define red-color '(255 10 10))
  133.   (define green-color '(10 255 10))
  134.   (define blue-color '(10 10 255))
  135.   (define hue-segment #f)
  136.   (define saturation-segment #f)
  137.   (define value-segment #f)
  138.   (define red-segment #f)
  139.   (define green-segment #f)
  140.   (define blue-segment #f)
  141.   (define border-size 10)
  142.  
  143.   (define (fill-dot img drawable x y segment color)
  144.     (if (fill-segment! segment x y)
  145.     (begin
  146.       (gimp-context-set-foreground color)
  147.       (draw-segment img drawable segment (segment-max-size segment) color)
  148.       #t)
  149.     #f))
  150.  
  151.   (define (fill-color-band img drawable x scale x-base y-base color)
  152.     (gimp-context-set-foreground color)
  153.     (gimp-rect-select img (+ x-base (* scale x)) 0 scale y-base CHANNEL-OP-REPLACE FALSE 0)
  154.     (gimp-edit-bucket-fill drawable FG-BUCKET-FILL NORMAL-MODE 100 0 FALSE 0 0)
  155.     (gimp-selection-none img))
  156.  
  157.   (define (plot-hsv img drawable x scale x-base y-base hsv)
  158.     (let ((real-x (* scale x))
  159.       (h (car hsv))
  160.       (s (cadr hsv))
  161.       (v (caddr hsv)))
  162.       (fill-dot img drawable (+ x-base real-x) (- y-base h)
  163.         hue-segment red-color)
  164.       (fill-dot img drawable (+ x-base real-x) (- y-base s)
  165.         saturation-segment green-color)
  166.       (if (fill-dot img drawable (+ x-base real-x) (- y-base v)
  167.             value-segment blue-color)
  168.       (gimp-displays-flush))))
  169.  
  170.   (define (plot-rgb img drawable x scale x-base y-base hsv)
  171.     (let ((real-x (* scale x))
  172.       (h (car hsv))
  173.       (s (cadr hsv))
  174.       (v (caddr hsv)))
  175.       (fill-dot img drawable (+ x-base real-x) (- y-base h)
  176.         red-segment red-color)
  177.       (fill-dot img drawable (+ x-base real-x) (- y-base s)
  178.         green-segment green-color)
  179.       (if (fill-dot img drawable (+ x-base real-x) (- y-base v)
  180.             blue-segment blue-color)
  181.       (gimp-displays-flush))))
  182.  
  183.   (define (clamp-value x minv maxv)
  184.     (if (< x minv)
  185.     (set! x minv))
  186.     (if (< maxv x)
  187.     (set! x maxv))
  188.     x)
  189.  
  190.   ;; start of script-fu-hsv-graph
  191.   (if (= TRUE bounds?)
  192.       (if (= TRUE (car (gimp-selection-bounds img)))
  193.       (let ((results (gimp-selection-bounds img)))
  194.         (set! beg-x (nth (if (= TRUE left2right?) 1 3) results))
  195.         (set! beg-y (nth 2 results))
  196.         (set! end-x (nth (if (= TRUE left2right?) 3 1) results))
  197.         (set! end-y (nth 4 results)))
  198.       (let ((offsets (gimp-drawable-offsets drawable)))
  199.         (set! beg-x (if (= TRUE left2right?)
  200.                 (nth 0 offsets)
  201.                 (- (+ (nth 0 offsets)
  202.                   (car (gimp-drawable-width drawable)))
  203.                    1)))
  204.         (set! beg-y (nth 1 offsets))
  205.         (set! end-x (if (= TRUE left2right?)
  206.                 (- (+ (nth 0 offsets)
  207.                   (car (gimp-drawable-width drawable)))
  208.                    1)
  209.                 (nth 0 offsets)))
  210.         (set! end-y (- (+ (nth 1 offsets)
  211.                   (car (gimp-drawable-height drawable)))
  212.                1))))
  213.       (let ((offsets (gimp-drawable-offsets drawable)))
  214.     (set! beg-x (clamp-value beg-x 0
  215.                  (+ (nth 0 offsets)
  216.                     (car (gimp-drawable-width drawable)))))
  217.     (set! end-x (clamp-value end-x 0
  218.                  (+ (nth 0 offsets)
  219.                     (car (gimp-drawable-width drawable)))))
  220.     (set! beg-y (clamp-value beg-y 0
  221.                  (+ (nth 1 offsets)
  222.                     (car (gimp-drawable-height drawable)))))
  223.     (set! end-y (clamp-value end-y 0
  224.                  (+ (nth 1 offsets)
  225.                     (car (gimp-drawable-height drawable)))))))
  226.   (set! opacity (clamp-value opacity 0 100))
  227.   (let* ((x-len (- end-x beg-x))
  228.      (y-len (- end-y beg-y))
  229.      (limit (pow (+ (pow x-len 2) (pow y-len 2)) 0.5))
  230.      (gimg-width (* limit scale))
  231.      (gimg-height 256)
  232.      (gimg (car (gimp-image-new (+ (* 2 border-size) gimg-width)
  233.                     (+ (* 2 border-size) gimg-height) RGB)))
  234.      (bglayer (car (gimp-layer-new gimg
  235.                        (+ (* 2 border-size) gimg-width)
  236.                        (+ (* 2 border-size) gimg-height)
  237.                        1 "Background" 100 NORMAL-MODE)))
  238.      (hsv-layer (car (gimp-layer-new gimg
  239.                        (+ (* 2 border-size) gimg-width)
  240.                        (+ (* 2 border-size) gimg-height)
  241.                       RGBA-IMAGE "HSV Graph" 100 NORMAL-MODE)))
  242.      (rgb-layer (car (gimp-layer-new gimg
  243.                        (+ (* 2 border-size) gimg-width)
  244.                        (+ (* 2 border-size) gimg-height)
  245.                       RGBA-IMAGE "RGB Graph" 100 NORMAL-MODE)))
  246.      (clayer (car (gimp-layer-new gimg gimg-width 40 RGBA-IMAGE
  247.                        "Color Sampled" opacity NORMAL-MODE)))
  248.      (rgb '(255 255 255))
  249.      (hsv '(254 255 255))
  250.      (x-base border-size)
  251.      (y-base (+ gimg-height border-size))
  252.      (index 0))
  253.  
  254.     (gimp-context-push)
  255.  
  256.     (gimp-image-undo-disable gimg)
  257.     (gimp-image-add-layer gimg bglayer -1)
  258.     (gimp-selection-all gimg)
  259.     (gimp-context-set-background '(255 255 255))
  260.     (gimp-edit-fill bglayer BACKGROUND-FILL)
  261.     (gimp-image-add-layer gimg hsv-layer -1)
  262.     (gimp-edit-clear hsv-layer)
  263.     (gimp-image-add-layer gimg rgb-layer -1)
  264.     (gimp-drawable-set-visible rgb-layer FALSE)
  265.     (gimp-edit-clear rgb-layer)
  266.     (gimp-image-add-layer gimg clayer -1)
  267.     (gimp-edit-clear clayer)
  268.     (gimp-layer-translate clayer border-size 0)
  269.     (gimp-selection-none gimg)
  270.     (set! red-segment (make-segment 64 x-base y-base))
  271.     (set! green-segment (make-segment 64 x-base y-base))
  272.     (set! blue-segment (make-segment 64 x-base y-base))
  273.     (set! hue-segment (make-segment 64 x-base y-base))
  274.     (set! saturation-segment (make-segment 64 x-base y-base))
  275.     (set! value-segment (make-segment 64 x-base y-base))
  276.     (gimp-context-set-brush "Circle (01)")
  277.     (gimp-context-set-paint-mode NORMAL-MODE)
  278.     (gimp-context-set-opacity 70)
  279.     (gimp-display-new gimg)
  280.     (while (< index limit)
  281.       (set! rgb (car (gimp-image-pick-color img drawable
  282.                         (+ beg-x (* x-len (/ index limit)))
  283.                         (+ beg-y (* y-len (/ index limit)))
  284.                         TRUE FALSE 0)))
  285.       (fill-color-band gimg clayer index scale x-base 40 rgb)
  286.       (rgb-to-hsv rgb hsv)
  287.       (plot-hsv gimg hsv-layer index scale x-base y-base hsv)
  288.       (plot-rgb gimg rgb-layer index scale x-base y-base rgb)
  289.       (set! index (+ index 1)))
  290.     (mapcar
  291.      (lambda (segment color)
  292.        (if (< 1 (segment-filled-size segment))
  293.     (begin
  294.       (gimp-context-set-foreground color)
  295.       (draw-segment gimg hsv-layer segment (segment-filled-size segment)
  296.             color))))
  297.      (list hue-segment saturation-segment value-segment)
  298.      (list red-color green-color blue-color))
  299.     (mapcar
  300.      (lambda (segment color)
  301.        (if (< 1 (segment-filled-size segment))
  302.     (begin
  303.       (gimp-context-set-foreground color)
  304.       (draw-segment gimg rgb-layer segment (segment-filled-size segment)
  305.             color))))
  306.      (list red-segment green-segment blue-segment)
  307.      (list red-color green-color blue-color))
  308.     (gimp-context-set-foreground '(255 255 255))
  309.     (let ((text-layer (car (gimp-text-fontname gimg -1 0 0
  310.                       "Red: Hue, Green: Sat, Blue: Val"
  311.                       1 1 12 PIXELS
  312.                       "Sans")))
  313.       (offset-y (- y-base (car (gimp-drawable-height clayer)))))
  314.       (gimp-layer-set-mode text-layer DIFFERENCE-MODE)
  315.       (gimp-layer-translate clayer 0 offset-y)
  316.       (gimp-layer-translate text-layer border-size (+ offset-y 15)))
  317.     (gimp-image-set-active-layer gimg bglayer)
  318.     (gimp-image-clean-all gimg)
  319.     (gimp-image-undo-enable gimg)
  320.  
  321.     (set! script-fu-hsv-graph-scale scale)
  322.     (set! script-fu-hsv-graph-opacity opacity)
  323.     (set! script-fu-hsv-graph-bounds? bounds?)
  324.     (set! script-fu-hsv-graph-left2right? left2right?)
  325.     (set! script-fu-hsv-graph-beg-x beg-x)
  326.     (set! script-fu-hsv-graph-beg-y beg-y)
  327.     (set! script-fu-hsv-graph-end-x end-x)
  328.     (set! script-fu-hsv-graph-end-y end-y)
  329.     (gimp-displays-flush)
  330.  
  331.     (gimp-context-pop)))
  332.  
  333. (script-fu-register "script-fu-hsv-graph"
  334.             _"Draw _HSV Graph..."
  335.             "Draph the graph of H/S/V values on the drawable"
  336.             "Shuji Narazaki <narazaki@InetQ.or.jp>"
  337.             "Shuji Narazaki"
  338.             "1997"
  339.             "RGB*"
  340.             SF-IMAGE       "Image to analyze"    0
  341.             SF-DRAWABLE    "Drawable to analyze" 0
  342.             SF-ADJUSTMENT _"Graph scale" (cons script-fu-hsv-graph-scale '(0.1 5 0.1 1 1 1))
  343.             SF-ADJUSTMENT _"BG opacity"  (cons script-fu-hsv-graph-opacity '(0 100 1 10 0 1))
  344.             SF-TOGGLE     _"Use selection bounds instead of belows" script-fu-hsv-graph-bounds?
  345.             SF-TOGGLE     _"From top-left to bottom-right" script-fu-hsv-graph-left2right?
  346.             SF-ADJUSTMENT _"Start X" (cons script-fu-hsv-graph-beg-x '(0 5000 1 10 0 1))
  347.             SF-ADJUSTMENT _"Start Y" (cons script-fu-hsv-graph-beg-y '(0 5000 1 10 0 1))
  348.             SF-ADJUSTMENT _"End X" (cons script-fu-hsv-graph-end-x '(0 5000 1 10 0 1))
  349.             SF-ADJUSTMENT _"End Y" (cons script-fu-hsv-graph-end-y '(0 5000 1 10 0 1)))
  350.  
  351. (script-fu-menu-register "script-fu-hsv-graph"
  352.              _"<Image>/Script-Fu/Utils")
  353.